home *** CD-ROM | disk | FTP | other *** search
/ PC-X 1997 October / pcx14_9710.iso / swag / delphi.swg / 0182_Hook into the WINCRT unit.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-11-29  |  14.7 KB  |  479 lines
  1. {
  2. I have just extended some PD sources (in this month's SWAG - HOOKCRT.PAS) to
  3. convert it to a unit, with supporting Pascal Object and Delphi Class. This
  4. hooks into the WinCRT unit (BPW and Delphi 1.x) to add menus, etc. A sample
  5. program is included. You might wish to add this to the SWAG archives.
  6. Thanks.
  7.  
  8. ------------------------------ cut ------------------------------ }
  9. Unit HookCrt2;
  10.  
  11. { ----- ORIGINAL MESSAGE ---
  12.   The intent of this program is to provide the ability to add additional functionality
  13.   to WinCRT.  Like the ablity to add and use a menubar and to be able to respond to
  14.   mouse clicks.
  15.  
  16.   WinCRT does NOT need to be modified to run this app.
  17.  
  18.   This program is Public Domain by Cedar Island Software. Use it as you see fit.
  19.   All the usual disclaimers apply.
  20.  
  21.   Thanks to Neil Rubenking and his book 'Turbo Pascal for Windows Techniques and Utilities'.
  22.   Thanks to Kurt Barthlemess of BPASCAL (TeamB).
  23.   Thanks also to Paul A. LeBlanc of BCPPWIN (TeamB).
  24.  
  25.  
  26.   Good Luck and Have Fun.
  27.   Mike Caughran
  28.   Cedar Island Software
  29.   [71034,2371]
  30.  
  31.   ---- ADDED MESSAGE by Dr A Olowofoyeku ------
  32.   September 1996
  33.   Amended and Extended by Dr A Olowofoyeku (The African Chief);
  34.    [a] converted to a unit
  35.    [b] a Pascal object (and Delphi Class) to encapsulate the
  36.        unit's functionality.
  37.    [c] some default procedural types and functions
  38.    [d] MyInitWinCRT changed to: HookedInitWinCRT - and now
  39.        takes some parameters
  40.    [e] MyDoneWinCRT changed to: HookedDoneWinCrt;
  41.    [f] supports Delphi 1.x
  42.  
  43.   Enjoy!
  44.  
  45.   THIS UNIT IS PUBLIC DOMAIN -
  46.   NOTHING IS WARRANTEED. USE AT YOUR OWN RISK!
  47.  
  48.   Dr A. Olowofoyeku (The African Chief)
  49.   Email: laa12@cc.keele.ac.uk
  50.   http://ourworld.compuserve.com/homepages/African_Chief/
  51. }
  52.  
  53. Interface
  54. {$ifdef Ver80}     {Delphi 1.x}
  55.    {$Define Delphi}
  56. {$endif Ver80}
  57.  
  58. uses {$ifndef Delphi}Objects {$else}Messages{$endif},WinCRT, WinTypes, WinProcs;
  59.  
  60. {/////////////////////////////////////////////////////////////}
  61. {////////////// exported data and functions //////////////////}
  62. {/////////////////////////////////////////////////////////////}
  63. {custom icon for CRT window}
  64.   Var
  65.   CrtappIcon : hIcon;
  66.  
  67. {  User menu command tags (identifiers)
  68.    start from 1 to 64 for CRT menu tags
  69. }
  70.   Const
  71.   cm_User1   = 1;
  72.   cm_UserMax = 64;
  73.  
  74. {Crt Window function type}
  75. Type
  76. aWindowFunc = Function(Window : HWnd; Message : Word;
  77.                        wParam : Word; lParam : LongInt) : LongInt;
  78.  
  79. {menu command procedural type}
  80. aMenuFunc   = Procedure(Const aTag:integer);
  81.  
  82.  
  83. {create a CRT window}
  84. Function  HookedInitWinCRT(
  85. Const
  86. Left,                 {left side of the window}
  87. Top,                  {top of the window}
  88. width,                {width of the window}
  89. height:integer;       {height of the window}
  90. Title :pChar ;        {window title}
  91. aWinProc:aWindowFunc; {new window function, or Nil for default}
  92. MenuFunc:aMenuFunc    {new window procedure, or Nil for default}
  93. ):HWnd;                 {returns the handle to the CRT window}
  94.  
  95. {destroy a CRT window}
  96. Function HookedDoneWinCRT : Boolean;
  97.  
  98. {/////////////////////////////////////////////////////////////}
  99. {///////////////////// CRT object ////////////////////////////}
  100. {// This object encapsulates the functionality of this unit //}
  101. {/////////////////////////////////////////////////////////////}
  102. {/////////////////////////////////////////////////////////////}
  103. Type
  104. TNewCrtClass = {$ifdef Delphi}Class{$else}Object(TObject){$endif}
  105.    HWindow : HWnd; {handle of the CRT window}
  106.  
  107.    Constructor {$ifdef Delphi}Create{$else}Init{$endif}
  108.    {init constructor - calls HookedInitWinCRT with all these
  109.    parameters, to create the CRT window}
  110.    (Const
  111.    Left,                 {left side of the window}
  112.    Top,                  {top of the window}
  113.    width,                {width of the window}
  114.    height:integer;       {height of the window}
  115.    Title :pChar ;        {window title}
  116.    aWinProc:aWindowFunc; {new window function, or Nil for default}
  117.    MenuFunc:aMenuFunc    {new window procedure, or Nil for default}
  118.    );
  119.  
  120.    Destructor {$ifDef Delphi}Destroy;override{$else}Done; virtual{$endif};
  121.  
  122.    Procedure   MakeMainMenu(Caption:pChar;Tag:integer);virtual;
  123.    {create a main menu item = e.g., File Menu, Edit, etc.
  124.    Caption = the title of the menu
  125.    Tag     = the command tag
  126.    }
  127.  
  128.    Procedure   MakeSubMenu(ParentNum:Byte;Caption:pChar;Tag:integer);virtual;
  129.    {create a submenu under the main menu "parentnum"
  130.    ParentNum = the numeric ID of the parent main menu
  131.    Caption = the title of the menu
  132.    Tag     = the command tag
  133.    }
  134.    Procedure   MakeSeparator(ParentNum:Byte);virtual;
  135.    {create a menu separator under the main menu "parentnum"
  136.    ParentNum = the numeric ID of the parent main menu
  137.    }
  138.  
  139.    Procedure   AssignCRTMenu;virtual;
  140.    {assign the menu to the CRT window and repaint the menu;
  141.    MUST be called at some stage - normall AFTER all the menu
  142.    items have been create.}
  143.  
  144.    Private
  145.      MainMenus : Array[0..32] of HMenu; {max 32 main MainMenus}
  146.      MenuCount : Word; {number of main MainMenus created}
  147. end;{end of CRT object}
  148. {////////////////////////////////////////////////}
  149. Var
  150.   OldCRTProc   : TFarProc;{pointer to old window function}
  151.   NewCRTHandle : HWND;  {handle to CRT window}
  152.  
  153. implementation
  154.  
  155. var
  156.   NewCRTProc : TFarProc; {pointer to new window function}
  157.  
  158. Var
  159. DefMenuFunc:aMenuFunc;{menu command function}
  160.  
  161. {////////////////////////////////////////////////}
  162. function NewDefaultMsgHandler(Window : HWnd; Message : Word;
  163. {default message handler - if none is specified in call to
  164. HookedInitWinCRT}
  165. wParam : Word; lParam : LongInt) : LongInt; export;
  166. begin
  167.   case Message of
  168.     wm_Command  : begin
  169.       case WParam of
  170.         cm_User1 .. cm_UserMax:
  171.         If @DefMenuFunc<> Nil then DefMenuFunc(WParam);
  172.       end;
  173.     end;
  174.   end;
  175.   NewDefaultMsgHandler := CallWindowProc(OldCRTProc, Window, Message, wParam, lParam);
  176. end;
  177. {////////////////////////////////////////////////}
  178. {////////////////////////////////////////////////}
  179. {////////////////////////////////////////////////}
  180. {////////////////////////////////////////////////}
  181. Constructor TNewCrtClass.{$ifdef Delphi}Create{$else}Init{$endif};
  182. Begin
  183.    Inherited {$ifdef Delphi}Create;{$else}Init;{$endif}
  184.    HWindow := HookedInitWinCrt
  185.    (Left,Top,width,height,Title,aWinProc,MenuFunc);
  186.  
  187.    FillChar(MainMenus, Sizeof(MainMenus), #0);
  188.    MainMenus[0] := CreateMenu;
  189.    MenuCount := 0;
  190. End;
  191. {////////////////////////////////////////////////}
  192. Destructor TNewCrtClass.{$ifDef Delphi}Destroy{$else}Done{$endif};
  193. Begin
  194.     FillChar(MainMenus, Sizeof(MainMenus), #0);
  195.     MenuCount := 0;
  196.     HWindow   := 0;
  197.     HookedDoneWinCRT;
  198.    {$ifdef Delphi}
  199.     Inherited Destroy;
  200.    {$else}
  201.     Inherited Done;
  202.    {$endif}
  203. End;
  204. {////////////////////////////////////////////////}
  205. Procedure TNewCrtClass.MakeMainMenu;
  206. Begin
  207.    If MenuCount>=32 then Exit;
  208.    If Tag > 0 then AppendMenu(MainMenus[0], mf_Enabled, Tag, Caption)
  209.    else begin
  210.      Inc(MenuCount);
  211.      MainMenus[MenuCount] := CreateMenu;
  212.      AppendMenu(MainMenus[0], mf_PopUp or mf_Enabled, MainMenus[MenuCount], Caption);
  213.    end;
  214. End;
  215. {////////////////////////////////////////////////}
  216. Procedure TNewCrtClass.MakeSubMenu;
  217. Begin
  218.   If (ParentNum<1) or (ParentNum>32) then exit;
  219.   AppendMenu(MainMenus[ParentNum], mf_Enabled, Tag, Caption);
  220. End;
  221. {////////////////////////////////////////////////}
  222. Procedure TNewCrtClass.MakeSeparator;
  223. Begin
  224.   If (ParentNum<1) or (ParentNum>32) then exit;
  225.   AppendMenu(MainMenus[ParentNum], mf_Separator,0, '');
  226. End;
  227. {////////////////////////////////////////////////}
  228. Procedure TNewCrtClass.AssignCRTMenu;
  229. Begin
  230.   SetMenu(HWindow,MainMenus[0]);
  231. End;
  232. {////////////////////////////////////////////////}
  233. {////////////////////////////////////////////////}
  234. function  GetCRTWindowHandle: HWnd;
  235. {return handle to the CRT window}
  236. begin
  237.   ClrScr;   {force active window}
  238.   GetCRTWindowHandle := GetActiveWindow;
  239. end;
  240. {////////////////////////////////////////////////}
  241. Procedure GetScreenResolution(Var aTPoint : TPoint);
  242. {get the current screen resolution and return it in "T"}
  243. Var
  244. HD : HDC;
  245. Wn : HWnd;
  246. Begin
  247.    Wn := GetDesktopWindow;
  248.    Hd := GetDC(Wn);
  249.    With aTPoint do begin
  250.      X := GetDeviceCaps(Hd, HorzRes);
  251.      Y := GetDeviceCaps(Hd, VertRes);
  252.    End;
  253.    ReleaseDC(Wn, Hd);
  254. End;
  255. {////////////////////////////////////////////////}
  256. Procedure SetWindowCoordinates;
  257. {set up CRT window for possible scrolling}
  258. Var
  259. aPoint : tpoint;
  260. aReal  : real;
  261. anInt  : integer;
  262.  
  263. Begin
  264.    GetScreenResolution(aPoint);
  265.  
  266.    With aPoint do
  267.    begin
  268.       aReal := Y /25;
  269.       If y >  768 then aReal := (aReal*13.2) else
  270.       If Y >= 600 then aReal := (aReal*15.8) else
  271.       aReal := (aReal*18.4);
  272.  
  273.       anInt := round(aReal + 25);
  274.       WindowSize.Y := anInt;
  275.  
  276.       If X > 800 then anInt := 11 else anInt := 10;
  277.       WindowSize.X := (ScreenSize.X * anInt);
  278.    end;
  279. End;
  280. {////////////////////////////////////////////////}
  281. {////////////////////////////////////////////////}
  282.  
  283. Function  HookedInitWinCRT;
  284. {initialise the new crt stuff}
  285. Begin
  286.   {window location coordinates}
  287.   With WindowOrg do begin
  288.      x := Left;
  289.      y := Top;
  290.   end;
  291.  
  292.  {the size of the CRT window buffer}
  293.   With ScreenSize do begin
  294.      x := Width;
  295.      y := Height;
  296.   end;
  297.  
  298.   {setup the window properly}
  299.   SetWindowCoordinates;
  300.  
  301.   {set window title}
  302.   lStrCpy(WindowTitle, Title);
  303.  
  304.   {call WinCRT.InitWinCRT}
  305.   InitWinCrt;
  306.  
  307.  {get the CRT window handle}
  308.   NewCRTHandle := GetCRTWindowHandle;
  309.   {SetWindowText(NewCRTHandle, Title);}
  310.  
  311.   {save old window proc}
  312.   OldCRTProc := TFarProc(GetWindowLong(NewCRTHandle, gwl_WndProc));
  313.  
  314.   {assign new window proc}
  315.   If @aWinProc<>Nil then
  316.   NewCrtProc := MakeProcInstance(@aWinProc, hInstance)
  317.   else
  318.   NewCrtProc := MakeProcInstance(@NewDefaultMsgHandler, hInstance);
  319.  
  320.   {make it happen!}
  321.   SetWindowLong(NewCRTHandle, gwl_WndProc, LongInt(NewCrtProc));
  322.  
  323.   {assign CRT menu proc}
  324.   If @MenuFunc <> Nil then DefMenuFunc := MenuFunc;
  325.  
  326.   {if custom icon used, assign it}
  327.   If CrtappIcon<>0 then
  328.   SetClassWord(NewCRTHandle, gcw_hIcon, CrtappIcon);
  329.  
  330.  {return handle of CRT window}
  331.   HookedInitWinCRT := NewCRTHandle;
  332. End;
  333. {////////////////////////////////////////////////}
  334. Function  HookedDoneWinCRT;
  335. {dispose of the new crt window}
  336. begin
  337.   DoneWinCrt; {call WinCRT.DoneWinCrt}
  338.   HookedDoneWinCRT:=True;
  339.  
  340.   {do other stuff}
  341.   CrtappIcon := 0;
  342.   NewCRTHandle:=0;
  343.   FreeProcInstance(NewCrtProc);
  344.   DefMenuFunc := Nil;
  345. end;
  346. {////////////////////////////////////////////////}
  347. {////////////////////////////////////////////////}
  348. {////////////////////////////////////////////////}
  349. {///////// initialisation block /////////////////}
  350. {////////////////////////////////////////////////}
  351. begin
  352.    CrtappIcon   := 0;
  353.    NewCRTHandle := 0;
  354.    DefMenuFunc  := Nil;
  355. end.
  356. {////////////////////////////////////////////////}
  357. {////////////////////////////////////////////////}
  358. {// TEST PROGRAM: shows usage of HOOKCRT2.PAS ///}
  359. {////////////////////////////////////////////////}
  360. {////////////////////////////////////////////////}
  361. Program TestCRT;
  362. {$ifdef Ver80}
  363.    {$Define Delphi}
  364. {$endif Ver80}
  365.  
  366. uses {$ifdef Delphi}Messages,{$endif}WinTypes,
  367. WinProcs, HookCrt2, WinCrt;
  368.  
  369.   {menu constants: start from 1 - to infinity}
  370.   Const
  371.   cm_Exit    = 1;
  372.   cm_About   = 2;
  373.   cm_Clear   = 3;
  374.  
  375. Var
  376. TestCrtObj : TNewCrtClass;
  377.  
  378. {////////////////////////////////////////////////}
  379. {////////////////////////////////////////////////}
  380. Procedure ExecMenus(Const Tag:Integer);forward;
  381. {a sample procedure to process menu choices}
  382.  
  383. function  ShellAbout(hwnd:HWND; Title,Text:PChar; icon:HICON):integer; external 'SHELL' index 22;
  384. {an "About" function}
  385. {////////////////////////////////////////////////}
  386. {////////////////////////////////////////////////}
  387. function TestProc(Window : HWnd; Message : Word;
  388. wParam : Word; lParam : LongInt) : LongInt; export;
  389. {sample new menu handler}
  390. begin
  391.   case Message of
  392.     wm_char        : begin {MessageBeep(0);} end;
  393.     wm_LButtonDown : MessageBox(NewCrtHandle,'Left button','Mouse',MB_OK);
  394.     wm_Command     : begin
  395.       case WParam of
  396.         cm_User1 .. cm_UserMax: ExecMenus(WParam);
  397.       end;
  398.     end;
  399.   end;
  400.  
  401.   {call the old window proc = essential!}
  402.   TestProc := CallWindowProc(OldCRTProc, Window, Message, wParam, lParam);
  403. end;
  404. {////////////////////////////////////////////////}
  405. Procedure ExecMenus(Const Tag:Integer);
  406. Begin
  407.   Case Tag of
  408.      cm_About:
  409.      ShellAbout(NewCrtHandle,'Hooked CRT#Cedar Island Software & The Chief','Hello World, from the Chief!',
  410.                   CrtappIcon);
  411.      cm_Exit:
  412.            TestCrtObj.{$ifDef Delphi}Free{$else}Done{$endif};
  413.      {HookedDoneWinCRT;}
  414.      cm_Clear: begin clrscr; gotoxy(1,1); end;
  415.   End;
  416. End;
  417. {////////////////////////////////////////////////}
  418. procedure DoTest;
  419. var
  420.   Name    : String;
  421. begin
  422.   LoadString(GetModuleHandle('USER'),514,@Name[1],79);
  423.   Name[0]:=Char(LStrLen(@Name[1]));
  424.   Writeln('Hello ',Name);
  425.   Writeln('Welcome to a Subclassed WinCRT World!');
  426.   readln;
  427. end;
  428. {////////////////////////////////////////////////}
  429. {////////////////////////////////////////////////}
  430. {//////////// program block  ////////////////////}
  431. begin
  432.    TestCrtObj{$ifdef Delphi}:= TNewCrtClass.Create{$else}.Init{$endif}
  433.    (1,1,80,25,'Chief''s Hooked CRT Window',TestProc,ExecMenus);
  434.  
  435.     With TestCrtObj do begin
  436.      MakeMainMenu('&File ', 0);
  437.        MakeSubMenu(1, '&New', 0);
  438.        MakeSubMenu(1, '&Open...', 0);
  439.        MakeSubMenu(1, '&Save', 0);
  440.        MakeSubMenu(1, 'Save &As ...', 0);
  441.        MakeSeparator(1);
  442.        MakeSubMenu(1,'E&xit', cm_Exit);
  443.  
  444.      MakeMainMenu('&Edit ', 0);
  445.        MakeSubMenu(2,'Cu&t    Shift+Del', 0);
  446.        MakeSubMenu(2,'&Copy   Ctrl+Ins', 0);
  447.        MakeSubMenu(2, '&Paste Shift+Ins', 0);
  448.        MakeSubMenu(2, 'C&lear Ctrl+Del', cm_Clear);
  449.        MakeSeparator(2);
  450.        MakeSubMenu(2,'E&xit', cm_Exit);
  451.  
  452.      MakeMainMenu('&Help ', 0);
  453.        MakeSubMenu(3,'&Contents  Shift+F1', 0);
  454.        MakeSubMenu(3,'&Topic Search', 0);
  455.        MakeSubMenu(3,'&Using Help', 0);
  456.        MakeSeparator(3);
  457.        MakeSubMenu(3,'&About ...', cm_About);
  458.        MakeSeparator(3);
  459.        MakeSubMenu(3,'E&xit', cm_Exit);
  460.  
  461.        AssignCrtMenu; {this MUST be called after creating all menus!!}
  462.  
  463.        DoTest;  {call a test procedure}
  464.  
  465.        {dispose of object and CRT window}
  466.        {$ifDef Delphi}Free{$else}Done{$endif};
  467.    end;
  468. end.
  469.  
  470.  
  471. [----------------------- end cut ------------------------]
  472. Warmest regards,
  473. The Chief
  474. ---------
  475. Dr. Abimbola A. Olowofoyeku  (The African Chief)
  476. Keele University, England    (and, The Great Elephant)
  477. Email: laa12@keele.ac.uk      or,  chief@mep.com
  478. http://ourworld.compuserve.com/homepages/African_Chief/chief.htm
  479.